home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / aeparse.tcl < prev    next >
Encoding:
Text File  |  2000-12-17  |  13.1 KB  |  438 lines
  1. ## -*-Tcl-*- (nowrap)
  2.  # ###################################################################
  3.  #  TclAE - Parsing functions for AEGizmo strings
  4.  # 
  5.  #  FILE: "aeparse.tcl"
  6.  #                                    created: 7/26/97 {6:44:05 PM} 
  7.  #                                last update: 11/26/2000 {8:43:46 PM} 
  8.  #  Author: Jonathan Guyer
  9.  #  E-mail: jguyer@his.com
  10.  #    mail: Alpha Cabal
  11.  #          POMODORO no seisan
  12.  #     www: http://www.his.com/jguyer/
  13.  #  
  14.  # ========================================================================
  15.  #               Copyright (c) 1997-2000 Jonathan Guyer
  16.  #                        All rights reserved
  17.  # ========================================================================
  18.  # Permission to use, copy, modify, and distribute this software and its
  19.  # documentation for any purpose and without fee is hereby granted,
  20.  # provided that the above copyright notice appear in all copies and that
  21.  # both that the copyright notice and warranty disclaimer appear in
  22.  # supporting documentation.
  23.  # 
  24.  # Jonathan Guyer disclaims all warranties with regard to this software,
  25.  # including all implied warranties of merchantability and fitness.  In
  26.  # no event shall Jonathan Guyer be liable for any special, indirect or
  27.  # consequential damages or any damages whatsoever resulting from loss of
  28.  # use, data or profits, whether in an action of contract, negligence or
  29.  # other tortuous action, arising out of or in connection with the use or
  30.  # performance of this software.
  31.  # ========================================================================
  32.  #  Description: 
  33.  # 
  34.  #  History
  35.  # 
  36.  #  modified   by  rev reason
  37.  #  ---------- --- --- -----------
  38.  #  1997-07-26 JEG 1.0 original
  39.  # ###################################################################
  40.  ##
  41.  
  42. ## 
  43.  # Note that 'try' is used very sparingly in this code because, although
  44.  # syntactically pleasing, it is too slow.  As it is, there are too many
  45.  # 'catch'es (Not anymore. Catch is gone).
  46.  ##
  47.  
  48. ## 
  49.  # With the exception of tclAE::parse::event, the parsers in this package 
  50.  # take the _name_ of a string variable as their argument and the 
  51.  # string is parsed in place.  Because it will typically be used to 
  52.  # parse the output of ‘AEBuild -r’, tclAE::parse::event takes a string 
  53.  # as its argument.  Since there is no forseeable reason for 
  54.  # external code to call any parser but tclAE::parse::event, this 
  55.  # distinction should not be a problem.
  56.  ##
  57.  
  58. namespace eval tclAE::parse {}
  59.  
  60. if {([info tclversion] < 8.0)
  61. ||    ![info exists tclAE_version] 
  62. ||  ($tclAE_version < 2.0)} {
  63.     
  64. # ◊◊◊◊ Grammar Rules ◊◊◊◊ #
  65.  
  66. # ◊◊◊◊  Public  ◊◊◊◊ #
  67.  
  68. ## 
  69.  # event ::= ident '\' ident keywordlist
  70.  # 
  71.  # NOTE:    This is the only parsing routine in this package 
  72.  #             which takes a string as an argument and, thus, can
  73.  #             have the output of ‘AEBuild -r’ piped into it.
  74.  ##
  75. proc tclAE::parse::event {chars args} {
  76.     if {[regexp {^([^\\]*)\\(.*)$} $chars blah class chars]} {
  77.     
  78.         # Make sure $class is formatted correctly
  79.         tclAE::parse::ident class class
  80.         tclAE::parse::ident chars eventID
  81.         
  82.         tclAE::parse::structure chars event
  83.         
  84.         tclAE::parse::throwIfError $event
  85.         
  86.         if {[string length [string trimleft $chars]] != 0} {
  87.             set errorMsg "Unexpected extra stuff past end"
  88.             error $errorMsg "" [list AEParse 3 $errorMsg]
  89.         } 
  90.         
  91.         global $event
  92.         # Set these manually, as we don't want them to show up as record keys
  93.         set ${event}(descriptorType)    "aevt"
  94.         set ${event}(basicType)            "aevt"
  95.         set ${event}(evcl)                $class
  96.         set ${event}(evid)                $eventID
  97.         
  98.     } else {
  99.         set errorMsg "Unexpected end of format string" 
  100.         error $errorMsg "" [list AEParse 2 $errorMsg]
  101.     }
  102.     
  103.     return $event
  104. }
  105.  
  106. # ◊◊◊◊  Private  ◊◊◊◊ #
  107.  
  108. ## 
  109.  # ident ::= identchar (identchar |    digit)*       —Padded/truncated
  110.  #             ' character* '                       to exactly 4    chars
  111.  ##
  112. proc tclAE::parse::ident {charsPtr resultPtr} {
  113.     upvar $charsPtr chars
  114.     upvar $resultPtr result
  115.     
  116.     set identchar {[^][(){} \r\t\n0-9'“”«»:,@]}
  117.     if {![regexp "^\\s*(${identchar}(${identchar}|\[0-9\])*)(.*)" $chars blah type blah chars]} {
  118.         if {![regexp "^\\s*'(\[^'\]*)'(.*)" $chars blah type chars]} {
  119.             set result "no ident"
  120.             return 0
  121.         }
  122.     }
  123.     set result [format "%-4.4s" $type]
  124.     return 1
  125. }
  126.  
  127. ## 
  128.  # obj ::= data                 —Single AEDesc; shortcut for (data)
  129.  #           structure         —Un-coerced structure
  130.  #           ident structure     —Coerced to some other    type
  131.  ##
  132. proc tclAE::parse::obj {charsPtr resultPtr} {
  133.     upvar $charsPtr chars
  134.     upvar $resultPtr result
  135.     
  136.     if {![catch {set result [tclAE::parse::event $chars]}]} {
  137.         return 1
  138.     } elseif {[tclAE::parse::data chars result]} {
  139.         global $result
  140.         if {[set ${result}(descriptorType)] == "enum"} {
  141.             if {[tclAE::parse::structure chars structure]} {
  142.                 global $structure
  143.                 
  144.                 set toType [coerce TEXT -x [set ${result}(dataRecord)] TEXT]
  145. #                 binary scan [set ${result}(dataRecord)] a4 toType
  146.                 tclAE::disposeDesc $result
  147.                 
  148.                 if {[catch {
  149.                     set coerceDesc [tclAE::_descriptorProc $structure coerceDesc]
  150.                     set result [$coerceDesc $structure $toType]
  151.                     tclAE::disposeDesc $structure
  152.                 }]} {
  153.                     set ${structure}(descriptorType) $toType
  154.                     set result $structure
  155.                 }
  156.             }
  157.         } 
  158.     } else {
  159.         return [tclAE::parse::structure chars result]
  160.     }
  161.     return 1
  162. }
  163.  
  164. ## 
  165.  # structure ::= ( data    )           —Single AEDesc
  166.  #                 [ objectlist ]       —AEList type
  167.  #                 { keywordlist }   —AERecord type
  168.  ##
  169. proc tclAE::parse::structure {charsPtr resultPtr} {
  170.     upvar $charsPtr chars
  171.     upvar $resultPtr result
  172.     
  173.     if {[regexp {^\s*\((.*)} $chars blah chars]} {
  174.         if {[tclAE::parse::data chars result]} {
  175.             if {![regexp {^\s*\)(.*)} $chars blah chars]} {
  176.                 set msg "Missing “)” after data value"
  177.                 error $msg "" [list AEParse 13 $msg]
  178.             }
  179.         } else {
  180.             if {$result == "no data"} {
  181.                 if {[regexp {^\s*\)(.*)} $chars blah chars]} {
  182.                     set result [tclAE::createDesc "null"]
  183.                 } else {
  184.                     set msg "Missing “)” after data value"
  185.                     error $msg "" [list AEParse 13 $msg]
  186.                 }
  187.             }
  188.         }
  189.     } elseif {![tclAE::parse::objectlist chars result]} {
  190.         if {![tclAE::parse::reco chars result]} {
  191.             set result "no structure"
  192.             return 0
  193.         }
  194.     }
  195.     
  196.     return 1
  197. }
  198.  
  199. ## 
  200.  #       list ::= [ objectlist ]
  201.  # objectlist ::= «blank»              —Comma-separated list    of things
  202.  #                  obj [    , obj ]*
  203.  #                  
  204.  # NOTE: proc is named 'objectlist' to avoid namespace collision
  205.  # and because the distinction is irrelevant here. 
  206.  # tclAE::parse::objectlist expects to find the [ ] brackets.
  207.  ##
  208. proc tclAE::parse::objectlist {charsPtr resultPtr} {
  209.     upvar $charsPtr chars
  210.     upvar $resultPtr theList
  211.     
  212.     if {[regexp {^\s*\[(.*)} $chars blah chars]} {
  213.         set theList [tclAE::createList]
  214.         global $theList
  215.         if {![regexp {^\s*\](.*)} $chars blah chars]} {
  216.             while 1 {
  217.                 tclAE::parse::obj chars item
  218.                 lappend ${theList}(dataRecord) $item
  219.                 regexp {^\s*(.)(.*)} $chars blah next chars
  220.                 if {$next == "\]"} {
  221.                     break
  222.                 } elseif {$next != ","} {
  223.                     tclAE::disposeDesc $theList
  224.                     set msg "Expected “,” or “\]”"
  225.                     error $msg "" [list AEParse 14 $msg]
  226.                 }        
  227.             }
  228.         }
  229.         return 1
  230.     } else {
  231.         set theList "no list"
  232.         return 0
  233.     }
  234. }
  235.  
  236. ## 
  237.  # keywordpair ::= ident : obj          —Keyword/value pair
  238.  ##
  239. proc tclAE::parse::keywordpair {charsPtr resultPtr record} {
  240.     upvar $charsPtr chars
  241.     upvar $resultPtr result
  242.     
  243.     if {[tclAE::parse::ident chars keyword]} {
  244.         if {[regexp {^\s*:(.*)} $chars blah chars]} {
  245.             tclAE::parse::obj chars value
  246.             
  247.             # too much overhead in tclAE::desc::_reco_putKeyDesc
  248.             global $record
  249.             if {[info exists ${record}($keyword)]} {
  250.                 catch {tclAE::disposeDesc [set ${record}($keyword)]}
  251.             } 
  252.             set ${record}($keyword) $value
  253.             
  254.             if {[lsearch -exact [set ${record}(dataRecord)] $keyword] == -1} {
  255.                 lappend ${record}(dataRecord) $keyword    
  256.             } 
  257.         } else {
  258.             set msg "Missing “:” after keyword in record"
  259.             error $msg "" [list AEParse 17 $msg]
  260.         }
  261.     } else {
  262.         if {$keyword == "no ident"} {
  263.             set msg "Missing keyword in record" 
  264.             error $msg "" [list AEParse 16 $msg]
  265.         }
  266.     }
  267. }
  268.  
  269. ## 
  270.  # record ::= { keywordlist }
  271.  # keywordlist ::= «blank»      —List of said pairs
  272.  #                              keywordpair [ , keywordpair ]*
  273.  ##
  274. proc tclAE::parse::reco {charsPtr resultPtr} {
  275.     upvar $charsPtr chars
  276.     upvar $resultPtr record
  277.     
  278.     if {[regexp {^\s*\{(.*)} $chars blah chars]} {
  279.         set record [tclAE::createList 1]        
  280.         if {![regexp {^\s*\}(.*)} $chars blah chars]} {
  281.             while 1 {
  282.                 tclAE::parse::keywordpair chars pair $record
  283.                 regexp {^\s*(.)(.*)} $chars blah next chars
  284.                 if {$next == "\}"} {
  285.                     break
  286.                 } elseif {$next != ","} {
  287.                     tclAE::disposeDesc $record
  288.                     set msg "Expected “,” or “\}”"
  289.                     error $msg "" [list AEParse 15 $msg]
  290.                 }
  291.             }
  292.         }
  293.         return 1
  294.     } else {
  295.         set record "no reco"
  296.         return 0
  297.     }
  298. }
  299.  
  300.  # integer ::=    [ - ] digit+    —Just as in C
  301.  # string ::=    “ (character)* ”
  302.  # hexstring ::=    « (hexdigit | whitespace)* »    —Even no. of digits, please
  303.  # data    ::=    @           —Gets appropriate data from fn param
  304.  #            integer       —'shor' or 'long' unless    coerced
  305.  #            ident       —A 4-char type code ('type')    unless coerced
  306.  #            string       —Unterminated text; 'TEXT' type unless coerced
  307.  #            hexstring  —Raw    hex    data; must be coerced to some type!
  308.  ##
  309. proc tclAE::parse::data {charsPtr resultPtr} {
  310.     upvar $charsPtr chars
  311.     upvar $resultPtr result
  312.     
  313.     if {[regexp {^\s*@(.*)} $chars blah chars]} {
  314.         set result [tclAE::createDesc "@" "@"]
  315.     } elseif {[regexp {^\s*(-?[0-9]+)(.*)$} $chars blah long chars]} {
  316.         if {[expr {$long > 32768}] || [expr {$long < -32767}]} {
  317.             set result [tclAE::createDesc "long" [coerce TEXT $long -x long]]
  318. #             set result [tclAE::createDesc "long" [binary format I $long]]
  319.         } else {
  320.             set short [coerce TEXT $long -x shor]
  321.             set result [tclAE::createDesc "shor" [coerce TEXT $long -x shor]]
  322. #             set result [tclAE::createDesc "shor" [binary format S $long]]
  323.         }
  324.     } elseif {[regexp {^\s*“([^”]*)”(.*)} $chars blah TEXT chars]} {
  325.         set result [tclAE::createDesc "TEXT" [coerce TEXT $TEXT -x TEXT]]
  326. #         set result [tclAE::createDesc "TEXT" [binary format a* $TEXT]]
  327.     } elseif {[regexp {^\s*«([0-9a-fA-F \r\t\n]*)»(.*)$} $chars blah hexd chars]} {
  328.         set result [tclAE::createDesc "hexd" $hexd]
  329.     } elseif {[tclAE::parse::ident chars ident]} {
  330.         set result [tclAE::createDesc "enum" [coerce TEXT $ident -x TEXT]]
  331. #         set result [tclAE::createDesc "enum" [binary format a* $ident]]
  332.     } else {
  333.         if {$ident == "no ident"} {
  334.             set result "no data"
  335.             return 0
  336.         }
  337.     }                          
  338.     return 1
  339. }
  340.  
  341. }
  342.  
  343. # ◊◊◊◊ Utilities ◊◊◊◊ #
  344.  
  345. ## 
  346.  # -------------------------------------------------------------------------
  347.  # 
  348.  # "tclAE::parse::throwIfError" --
  349.  # 
  350.  #  Look for error keys in 'event' and, if they exist, throw them 
  351.  # -------------------------------------------------------------------------
  352.  ##
  353. proc tclAE::parse::throwIfError {event} {
  354.     global error::OSErr errorCode $event
  355.     
  356.     set errn 0
  357.     set errs ""
  358.     
  359.     # No error if these keywords are missing
  360.     catch {set errn [tclAE::getKeyData $event "errn" "long"]}
  361.  
  362.     catch {set errs [tclAE::getKeyData $event "errs" "TEXT"]}
  363.     
  364.     if {[info exists error::OSErr($errn)]} {
  365.         if {[string length $errs] == 0} {
  366.             set errs [lindex [set error::OSErr($errn)] 2]
  367.         } 
  368.         set errn [set error::OSErr($errn)] 
  369.     } 
  370.     
  371.     if {(([string length $errn] != 0) && ($errn != 0))
  372.     ||    ([string length $errs] != 0)} {
  373.         error $errs "" $errn
  374.     }
  375. }
  376.  
  377. ## 
  378.  # -------------------------------------------------------------------------
  379.  # 
  380.  # "tclAE::parse::keywordValue" --
  381.  # 
  382.  #  This is just a wrapper from the old notation to the new one. 
  383.  #  Don't use it in new code.
  384.  # 
  385.  # Results:
  386.  #  The value of $keyword in $record
  387.  # -------------------------------------------------------------------------
  388.  ##
  389. proc tclAE::parse::keywordValue {keyword record {typed 0}} {
  390.     if {$typed} {
  391.         return [tclAE::getKeyDesc $record $keyword]
  392.     } else {
  393.         return [tclAE::getKeyData $record $keyword]
  394.     }
  395. }
  396.  
  397. proc tclAE::parse::queued {result} {
  398.     # Something's goofy with the
  399.     # form of 'result' as returned by AEPrint
  400.     
  401.     regsub -all -- {\\\{} $result "{" result
  402.     regsub -all -- {\\\}} $result "}" result
  403.     
  404.     # Get the direct object of the AppleEvent result and
  405.     # put it into a form palatable to Alpha Tcl
  406.     return [tclAE::parse::event $result]
  407. }
  408.  
  409. proc tclAE::parse::queuedResult {event} {
  410.     # Convert queued AEGizmos event into Tcl form
  411.     set event [tclAE::parse::queued $event]
  412.     
  413.     # Get the direct object of the queued AppleEvent
  414.     set result [tclAE::getKeyDesc $event ----]
  415.         
  416.     tclAE::disposeDesc $event
  417.  
  418.     return $result
  419. }
  420.  
  421.  
  422. # ◊◊◊◊ Legacy Definitions ◊◊◊◊ #
  423.  
  424. namespace eval aeparse {}
  425.  
  426. proc aeparse::event {chars args} {
  427.     return [eval tclAE::parse::event [list $chars] $args]
  428. }
  429.  
  430. proc aeparse::keywordValue {keyword record {typed 0}} {
  431.     if {$typed} {
  432.         return [tclAE::getKeyDesc $record $keyword]
  433.     } else {
  434.         return [tclAE::getKeyData $record $keyword]
  435.     }
  436. }
  437.  
  438.